perm filename ACCI.F4[P11,LCS] blob sn#590688 filedate 1981-05-30 generic text, type T, neo UTF8
C***** ACCI, DIAMND, RST ***********
	SUBROUTINE ACCI
	COMMON /INTGRS/JACC,JTAIL,JDOT,NTYPE,JSTEM,JWHOLE
	COMMON/DAT/RAC(69),RDT(17),XAC(7),RNTE(22),RACCI(22),NACCI(3)
	COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20) /STF/RSTFAC(0/7),RSTJ2
	COMMON /FONT/JFONT /PLTR/IPLT,RHT /POSI/STFF(0/7),JJ2,POS
	COMMON/ALF/INP(46),RST7,RST3,RSTX,RMINI,RINV,RA,RX,RJX,RJY
	EQUIVALENCE (R3,RJQ(1)),(J5,JQ(3)),(R5,RJQ(3))
	1,(R4,RJQ(2)),(RLVL,RJQ(20)),(R6,RJQ(4))

	RX=RMINI
	RR3=R3
	RR5=AMOD(R5,1.0)
	IF(RR5.NE.0)RR3=RR3-RR5*59.6*RMINI
C  TO SPACE OUT ACCIDS.
	IF(JACC.GT.3)GO TO 3121
C  DBL FLT(4) AND DBL SHRP(5)  ALWAYS USE 'DRAW' ROUTINE.
C ADD (#) ETC.
	IF(IPLT.LT.0)GO TO 3121
	IF(JFONT.NE.0)GO TO 3121
	NX=NACCI(JACC)
	CALL RDRAW(NX+1,RACCI(NX),RACCI,RMINI,RR3,CENTR,RMINI)
	RETURN
C  TO DRAW GOOD ACCIS ON PLOTTER - NOT ON DPY.(IN CLEF4.DMD)
3121	RA=R3
	R3=RR3
C	RJZ=AMOD(R4,100.0)
	J5=9
	IF(JACC.LT.6)GO TO 1
C NEXT FOR (#) ETC.
	R6=2.
	POS=POS+21.*RMINI
	RMINI=RMINI*2.0
C	R3=R3-3.*RMINI
	J5=99
1	J5=J5+JACC
	CALL DRWNT
	R3=RA
	RMINI=RX
	END
	SUBROUTINE DIAMND
	COMMON /INTGRS/JACC,JTAIL,JDOT,NTYPE,JSTEM,JWHOLE
	COMMON /WIDTH/WID1,WID2,WIDX
	COMMON/DAT/RACNT(69),RDOT(17),JXAC(7),RNOTE(22)
	COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20) /PLTR/IPLT,RHT,DIS,XDIS
	COMMON/ALF/INP(46),RST7,RST3,RSTX,RMINI,RINV,RA,RX,RJX,RJY,
	1 RB,RJW,RZ,JX,RG,KL,RJAC,K,L,RQ,RH,RZTM,RXX,JJJ
	EQUIVALENCE (R3,RJQ(1)),(J5,JQ(3)),(R4,RJQ(2)),(R6,RJQ(4))
	1,(R7,RJQ(5)),(RX4,JQ(19)),(ISTEM,JQ(20)),(J7,JQ(5)),(J6,JQ(4))
C DIAMOND NTS=180→279
	WIDX=WID1
C SET NOTE WIDTH FOR STEM ROUTINE
	 KL=8
	RG=12.0
C  FOR DIAMOND NOTES.
	RB=0
	IF(NTYPE.NE.3)GO TO 3
	KL=13
	RG=16.
	RB=7.*RMINI
C THESE FOR X-NOTE   =280→379
3	J4=R4
	RJZ=R4
	RX4=R4
	IF(J6.GE.0)GO TO 1
C NOW FOR BLACK DIAMOND (J6=-1)
	J6=0
	J5=7
	RQ=R7
	RG=CENTR
2	CALL DRWNT
	R7=RQ
	R4=RX4
	R6=0
	CENTR=RG
	RETURN

1	JT=1
C FOR DOUBLE-THICK X NOTES, HARMONICS.
	RH=R3
1253	CALL RDRAW(KL,RG,RNOTE,RMINI,RH,CENTR,RMINI)
	IF(JT.LT.0)RETURN
	IF(IPLT.GE.0)RETURN
	RH=RH-1.0
	JT=JT-1
	GO TO 1253
	END
	SUBROUTINE RST
	COMMON /INTGRS/JACC,JTAIL,JDOT
	COMMON R2,JA,CNTR,J2,R3,R4,R5,R6,R7,R8,R9,RJR(12),RX3
	1,J3,J4,J5,J6,J7,J8,J9
	1/LIMIT/LM,ITEM,LH,I,IX /STF/RF(8),RSTJ2 /XRN/RN(1)
      COMMON/PLTR/IPLT,RHT,DIS,XDIS /POSI/STFF(0/7),JJ2,POS
C  ITEMS IN FOLLOWING COMMON BLOCK ARE USED IN 'TAILS' AND 'FERM'
      COMMON/ALF/INP(46),RST7,RST3,RSTX,RMINI,RINV,RA,RX,RJX,RJY,
     1 RB,RJW,RZ,JX,RG,KL,RJAC,K,L,RQ,RH,J5X,RXX,JJJ
 
      IF(IABS(J4).LT.480)GO TO 22
	CALL EXTRA
C  P4+500= USER-ADDED RESTS
      RETURN
22	IF(J6.LT.0)RETURN
C J6=-1= INVIS. RESTS NEEDED IN 'PARTS' PROGRAM
	IF(R9.EQ.0)GO TO 302
	IF(R9.GT.0)GO TO 2

	J9=0
C USE R9 FOR CENTERING. ORIG. P3 IS BASIC POS.
C J9=0 NEEDED FOR CENTERED ./. REPEAT SIGN.**********
C IF R9<0 CENTERING WILL BE DONE IN RSTCEN
C FOR CENTERING WHOLE RESTS
	X=1000
C FINAL POSITION WILL BE 1/2 WAY FROM 1ST NOTE POS. TO BARLINE.
	DO 1 K=1,ITEM
	IF(CODN(K,L).NE.4)GO TO 1
	IF(RN(L).GT.2)GO TO 1
C FIND ONLY BARLINES (WDCNT=1)
	A=RN(L+3)
	IF(A.LT.X.AND.A.GT.RX3)X=A
1	CONTINUE
	IF(X.NE.1000)R9=RX3+(X-RX3)/2.-3.0*RSTJ2
C RX3 HAS IMPORTANT POS. INFO FOR NTS.
	IF(IPLT.GT.0)GO TO 2
	K=I
	IF(IPLT.NE.0)K=IX
C PUT R9 INTO NEW PLACE IN XRN
	RN(K-1)=R9
2	R3=RHORZ(R9)
	R9=0
C R9=0  SO LEDGER LINE FEATURE DOESN'T GET CONFUSED.

302   IF(R8.EQ.-3)R8=0
	 IF(R8.NE.0.AND.J5.NE.-3)J5=-2
C R8=-4 OR -5 MAKES REPEAT BAR SIGN
C R8=-3 IS FOR 'PAGE' PROGRAM
C SO THAT REST SHAPES ARE NOT CHANGED IN FULL BAR REST.
C R8 PUTS NUM OVER WHL RST ONLY. R5=-3 PUTS DBL WHL UNDER REST.
      IF(J5.GT.1)R4=R4-2.
      R7=R6*10.
C  FOR DOTS
      IF(J5.GE.2)R3=R3-3.0*RSTJ2
C  SHIFTS 1/16 AND SMALLER RESTS .5 TO LEFT
202	CALL REST
      IF(J5.GT.1)GO TO 200
      IF(R7.EQ.0)RETURN
201   RA=20.7
      R6=0
      IF(J5.LT.0)RA=25.7
      RJX=R3+RA*RMINI
C RJX HAS HOROZ. POS. FOR DOTIT ROUTINE.
      R4=8.+R4
      J5=7
C P6=1 THE REST IS DOTTED
	JDOT=J6
	CALL CENTX
	CALL DOTIT
	RETURN
200   J5=J5-1
C  FOR MULTIPLE TAILS ON 16TH REST, ETC.
      R4=R4+2.
      CALL RJBX(4.3)
      GO TO 202
	END